perm filename T1X.OLD[M11,LCS] blob
sn#409374 filedate 1979-01-04 generic text, type T, neo UTF8
C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
SUBROUTINE TRANS(JJJ)
DIMENSION IINS(135),FQDR(28,27)
C W(35) FOR PARAMETERS
COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,5),MX5(40)
1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
1,ENDX,J /KNAM/KNAM,IPLAY,JFLNM,IOPEN /IFIRST/IFIRST,IDT
COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
COMMON LL /P/W(1) /CONV/ICONV
INTEGER FQDR
CXX DOUBLE PRECISION IDBL,JANP,JBLA,IAT,IPERC,JFLNM,IDBG
EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
1,(IAROW,LX(7)),(W1,W),(W3,W(3))
CXX DATA LX/' ',';', '*','/','-','+'
CXX 1,'←','=', '<', ',', '(', ')'/, IFIRST/-1/,IOPEN/-1/
DATA LX/' ',';', '*','/','-','+'
1,"575004020100,'=','<' ,',' ,'(', ')'/, IOPEN/-1/
1 , IDOT/'.'/, IDEV/1/,JPRNT/1/,JWRT/-1/,JFLNM/'TRNS'/,IAT/'@ '/
1,JBLA/' '/,IDBG/'# '/,JDBG/'#'/
C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./
1,IEXP/'!'/,IPERC/'% '/,JANP/'& '/
1,IANP/'&'/,ICONV/-1/
1,IALT/"765004020100/
CXX 1,IALT/'"'/
C ICONV=-1 MEANS WRITE A SOUND FILE. (=0 = WRITE A FILE FOR 'SMPLS' PROG.)
GO TO (555,5002) JJJ
555 LLLL=0
401 IF(IFIRST)404, 5,600
404 IGEN=-1
IF(INUM.NE.0)GO TO 30
DO 411 K=1,135
411 IINS(K)=0
C ZERO OUT INSTR. NAME ARRAY.
30 IPLAY=0
ENDX=0
JSEM=0
INS=-1
402 IDEV=1
TYPE 1
1 FORMAT(' INPUT? '$)
100 FORMAT(' >'$)
2 FORMAT(A4)
ACCEPT 2,IDBL
C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
IF(IDBL.NE.JBLA)GO TO 400
IDEV=5
GO TO 5
400 IF(IDBL.EQ.JANP)GO TO 603
C!*** & IS PRNT-NOPRNT FLIPFLOP
IF(IDBL.NE.IDBG)GO TO 410
4448 TYPE 4023
4446 TYPE 4445
ACCEPT 51,KI
IF(KI.EQ.0)GO TO 4022
IF(KI.GT.0)GO TO 4447
C******** THIS STUFF FOR DIAGNOSIS
IF(KI.EQ.-1)TYPE 2325,IGEN
IF(KI.EQ.-2)TYPE 2325,IPRNT
IF(KI.EQ.-3)TYPE 2325,IPLAY
IF(KI.EQ.-4)TYPE 2325,JSEM
IF(KI.EQ.-5)TYPE 2325,J
IF(KI.EQ.-6)TYPE 2325,MM
GO TO 4446
4022 IF(IDEV.EQ.1)GO TO 402
C GO BACK TO 'INPUT' OR '>'
GO TO 502
C THIS WILL TYPE OUT ELEMENTS OF LX ARRAY.
4447 TYPE 2326,LX(KI)
TYPE 2325,LX(KI)
GO TO 4446
4445 FORMAT(' TYPE LX NUMB. '$)
4023 FORMAT(' IGEN, IPRNT, IPLAY, JSEM, J, MM'/)
4444 IF(IDBL.NE.IAT)GO TO 410
C!*** @ IS USED TO SET OUTPUT FILE NAME (DEFAULT=FOR21)
TYPE 399
399 FORMAT(' TYPE OUTPUT NAME -- ',$)
ACCEPT 2,JFLNM
GO TO 402
CCC IF(IDBL.EQ.'%')GO TO 604
C!*** % IS WRT-NOWRT FLIPFLOP
C! % WRITES BINARY FILE.
2324 FORMAT(1X12F/)
2325 FORMAT(1X5I/)
2326 FORMAT(1X80A1)
CX410 CALL OPEN(1,IDBL,0,'RDO')
410 CALL IFILE(1,IDBL)
4 FORMAT(80A1)
C****************
CX TYPE 2325,JSEM
CX TYPE 2325,J
CX TYPE 2325,MM
5 IF(JSEM.AND.J.LT.MM)GO TO 305
IF(JSEM.NE.99)GO TO 502
IFIRST=IFIRST+10
GO TO 555
600 JSEM=0
IFIRST=IFIRST-10
INS=-1
502 IF(IDEV.NE.5)GO TO 601
CX TYPE 2325,IDEV
C*******************************
IF(IGEN.NE.2)IGEN=-1
TYPE 100
CX601 TYPE 2325,INS
C*******************************
601 READ(IDEV,4,END=404)I
IF(IDEV.EQ.5)GO TO 1232
KI=80
1233 IF(I(KI).NE.IBLA)GO TO 1234
KI=KI-1
IF(KI.GT.0)GO TO 1233
1234 IF(JPRNT.LT.0)TYPE 2326,(I(IJI),IJI=1,KI)
GO TO 602
1232 IF(I(1).EQ.IBLA)GO TO 404
C!**** USE BLANK (<CR>) TO RETURN TO 'INPUT?'
IF(I(1).EQ.JDBG)GO TO 4448
C TYPE '#' FOR SOME DEBUGGING
CCC IF(I(1).EQ.'%')GO TO 604
C!*** %=WRITES BINARY FILE FOR21.DAT
IF(I(1).NE.IANP)GO TO 602
C!*** &=TYPE OUT MUS5 NUMBERS
603 JPRNT=-JPRNT
IF(IDEV.EQ.1)GO TO 402
C IDEV=1 = GO BACK TO 'INPUT'
GO TO 502
CCC604 JWRT=-JWRT
C!*** DEFAULT IS NO-WRITE BINARY
CCC GO TO 401
602 IF(I(1).NE.IALT)GO TO 408
CCC IF(I(2).NE.'I')GO TO 605
C!***<ALT>I(NSTRUMENT LIST;) ALT IS DBL QUOTE IN THIS PROG. FOR NOW.
DO 606 K=1,INUM
JK=NPAR(K)-2
606 TYPE 607,(INST(K,L),L=1,5),INSNUM(K),JK
GO TO 5
607 FORMAT(1X,5A1,' NUM=',I2,' PARAMS=',I2)
C!*** PRINTS INST INFO.
CCC605 SBFILN=FILNM
CCCCC CALL PLAY
C!**** GO PLAY SOMETHING
CCC GO TO 5
408 IF(I(1).NE.IEXP)GO TO 1408
C TRIGGERS ICONV FLIPFLOP
IF(ICONV)GO TO 2408
ICONV=-1
TYPE 3408
GO TO 502
2408 ICONV=0
TYPE 4408
GO TO 502
3408 FORMAT(' OUTPUT=TEST.SND'/)
4408 FORMAT(' OUTPUT=TEST.DAT'/)
1408 DO 407 K=1,100
407 JX(K)=IBLA
DO 405 K=1,80
IF(I(K).EQ.LESS)GO TO 5
405 IF(I(K).NE.IBLA)GO TO 406
GO TO 5
406 MM=0
DO 4061 J=2,100,2
4061 RX(J)=0
J=-1
IPRNT=0
JI=0
9 M=0
N=JI+1
6 JI=JI+1
K=I(JI)
DO 7 L=1,12
7 IF(K.EQ.LX(L))GO TO 8
M=M+1
GO TO 6
C!**** NO STRING CAN EXCEED 10 CHARS.
8 IF(K.EQ.LESS)GO TO 15
IF(M.EQ.0)GO TO 140
IF(M.GT.10)M=10
MM=MM+1
IF(MM.LE.50)GO TO 88
TYPE 888,(I(JJ),JJ=N,N+9)
STOP
888 FORMAT(' LINE TOO LONG -- ',10A1)
88 JJ=I(N)
IF(JJ.GT.'9')GO TO 16
IF(JJ.NE.IDOT.AND.JJ.LT.'0')GO TO 16
CXX IF(JJ.GT.8249)GO TO 16
CXX IF(JJ.NE.IDOT.AND.JJ.LT.8240)GO TO 16
C**** 8240='0' 8249='9'
C!***** JUMP IF 1ST CHAR. IS A LETTER.
Y=0
DOT=10.
DO 18 JK=N,N+M-1
JA=I(JK)
IF(JA.NE.IDOT)GO TO 17
DOT=.1
GO TO 18
CXX17 X=JA-8240
17 X=NASCI(JA)
C!**** CHANGE ASCII INTO NUMBER
IF(DOT.LT.1)GO TO 19
Y=Y*DOT+X
GO TO 18
19 Y=Y+X*DOT
DOT=DOT/10.
18 CONTINUE
RX(MM*2-1)=Y
RX(MM*2)=-9999.0
GO TO 140
CCC16161 FORMAT(1X,I,3X10A1)
16 JK=MM*2-1
CX JX(JK)=0
CX RX(JK)=0
CX JX(JK+1)=0
CX RX(JK+1)=0
CALL MPACK(M,I(N),JX(JK),N)
C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
IJ=JX(JK)
CCC IF(JPRNT)TYPE 16161,IJ,(I(KHH),KHH=N,N+M-1)
IF(IJ.GE.0)GO TO 244
JX(MM*2)=M
C SAVE THE WD CNT OF POTENTIAL INST. NAME.
GO TO 10
244 IF(IJ.NE.412)GO TO 140
C 412='INSTRUMENT'
INS=0
GO TO 5
144 MX=MX+1
MX5(MX)=IXJ
C!*** PUT IS NEW UNIT GEN. NAME
MX=MX+1
MX5(MX)=RX(3)
GO TO 5
140 IF(IJ.NE.413)GO TO 143
CCC140 IF(IXJ.NE.'UNIT')GO TO 143
INS=1
C!*** 'UNIT GENERATOR' IS RESERVED FOR NEW ONES.
GO TO 5
143 IF(K.EQ.IBLA)GO TO 10
IF(L.EQ.8)K=IAROW
C!::: CHANGE = INTO ←
MM=MM+1
KI=MM*2-1
JX(KI)=K
CC JX(MM*2-1)=K
10 IF(I(JI+1).NE.IBLA)GO TO 11
JI=JI+1
GO TO 10
11 IF(JI.LT.80)GO TO 9
C NOW WE HAVE ALL ITEMS IN IX ARRAY
15 MM=MM*2
IF(IJ.NE.404)GO TO 142
CCC IF(IXJ.NE.KPRNT)GO TO 142
INS=-1
C!***** FOR 'PRINT'
IPRNT=-1
142 J=-1
IF(INS.LT.0)GO TO 305
IF(INS.EQ.2)GO TO 305
26 IF(IJ.NE.12)GO TO 127
CCC26 IF(IXJ.NE.'END')GO TO 127
MM=0
INS=-1
C!***** NOW INITITIALIZATION COMPLETE
GO TO 5
127 IF(INS.EQ.1)GO TO 144
C!*** FOR 'UNIT GEN' ADDED
CXCX ASSUMES INST NAME STARTS IN COL.1 L=N-1
L=0
M=JX(2)
IF(INUM.EQ.0)GO TO 2127
DO 1127 KL=1,INUM
C!** FOR POSSIBLE REDEFINITION OF INST.
CC1127 IF(IXJ.EQ.INST(KL))GO TO 3127
DO 21 LQ=1,M
21 IF(INST(KL,LQ).NE.I(L+LQ))GO TO 1127
C TRY TO MATCH UP LETTERS WITH EXISTING INST. NAMES.
GO TO 3127
C!*** IS INST ALREADY IN LIST?
C JUMP OUT IF MATCH WAS FOUND
1127 CONTINUE
2127 INUM=INUM+1
K=INUM
CC3127 INST(K)=IXJ
DO 20 LQ=1,M
20 INST(K,LQ)=I(L+LQ)
C!**** GET THE NAME OF AN INST.(5 LTRS ONLY)
3127 INSNUM(K)=RX2
C!*** GET ITS NUMBER.
NPAR(K)=RX3+2
C!**** GET NUM OF PARAMS, ADD 3 FOR W ARRAY
DO 2328 KI=1,NPAR(INUM)
2328 FQDR(KI,INUM)=0
K=7
28 LL=-1
IF(JX(K).NE.410)GO TO 31
CCC IF(JX(K).NE.IDUR)GO TO 31
C IF IT'S NOT 'DUR' THEN IT MUST BE 'FREQ'
LL=-LL
C!*** NOW LOOK AT REST OF THE LINE
31 K=K+2
IF(K.GT.MM)GO TO 5
C!**** CHECK FOR END OF LINE
IF(RX(K+1).NE.-9999.0)GO TO 28
JA=RX(K)-2
CC JA=RX(K)+2
IF(JA.LT.1)GO TO 31
CC IF(JA.LT.5)GO TO 31
FQDR(JA,INUM)=LL
C!***** IGNORE P1,P2 OF INPUT
C!**** 1=DUR, -1=FREQ, 0=ORDINARY NUM.
GO TO 31
50 IF(IGEN)308,309,309
309 LL=LL-1
IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
C!*** FOUND 'END'
GO TO 59
308 W(1)=1
IF(LL-1.GE.NPAR(IK))GO TO 56
54 IF(LL.LT.3)LL=3
DO 55 K=LL,NPAR(IK)-1
55 W(K)=P(K-2)
C!***** GET INFO ALREADY IN PARAMS
56 DO 57 K=3,LL-1
57 P(K-2)=W(K)
C!**** FILL UP P LIST AGAIN
X=W(3)
C!*** EXCHANGE W(2) AND W(3), ACTION TIME, INST #
W(3)=W(2)
W(2)=X
58 LL=NPAR(IK)
DO 52 K=5,LL-1
KI=FQDR(K-4,IK)
CC X=FQDR(K-4,IK)
IF(KI)53,52,2352
CC IF(X.EQ.0)GO TO 52
CC IF(X)GO TO 53
2352 W(K)=RMAG/W(K)
GO TO 52
53 W(K)=RMAG*W(K)
52 CONTINUE
IF(ENDX.LT.W(2)+P2)ENDX=W(2)+P2
W(LL)=RMAG/W(4)
C!********* PUT MAG/P2 AT END
59 IF(W1.NE.2.)GO TO 592
IF(W3.NE.1)GO TO 595
PSV=0
SV=35
C EXPLAIN USE OF STORAGE PARAMS!!
595 IF(W3.NE.102.AND.W3.NE.105.AND.W3.NE.111.AND.W3.NE.104
1 .AND.W3.NE.115)GO TO 592
C 115=NOS, 102=OSC, 105=ENV, 104=RAI (3 STOR. LOCS), 111=RAH (2 STOR. LOCS)
C NEXT SETS UP STORAGE LOCATIONS FOR OSC, ENV, RAN, AND RAH.
DO 593 K=3,LL
X=W(K)
IF(X.LT.0.OR.X.GT.100)GO TO 593
IF(X.GT.PSV)PSV=X
C CHECK FOR OVERLAPPING PARAM NUMS.
593 CONTINUE
594 LL=LL+1
W(LL)=SV
SV=SV-1
C DECREMENT THE HIGH PARAM NUM.
IF(SV.LT.PSV)CALL ERROR(5)
C IF STORAGE PARAM NUM. OVERLAPS WITH INSTS/'S PARAMS = ERROR
X=W3
IF(X.NE.111.AND.X.NE.104)GO TO 592
IF(X.EQ.111)X=0
IF(X.EQ.104)X=111
GO TO 594
592 IF(JPRNT.GE.0)GO TO 591
CC TYPE 590,KNAM
KNAM=IBLA
TYPE 51,LL,(W(K),K=1,LL)
CXX WRITE(22,51)LL,(W(K),K=1,LL)
C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
591 IF(JWRT.GE.0)GO TO 500
CZZ IF(IOPEN.LT.0)CALL OFILE(21,JFLNM)
CXX IF(IOPEN.LT.0)CALL OPEN(21,JFLNM,0,'NEW',,,'UNF')
C OPENS FILE, IF NOT ALREADY OPEN.
CZZ WRITE(21)LL,(W(K),K=1,LL)
IDT=2
RETURN
5002 IOPEN=0
500 IFIRST=0
IF(IGEN.EQ.0)IGEN=-1
IF(W(1).NE.6)GO TO 555
RETURN
C W(1)=6 = 'FINISH;' [W ARRAY IS EQUIV. TO P ARRAY IN MUSIC5]
590 FORMAT(I6)
CCC590 FORMAT(1XA5,1X$)
306 IF(JPRNT.LT.0)TYPE 1307,(W(K),K=1,LL-1)
IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
IPRNT=0
C!** RESET NO-PRNT FLAG
JSEM=0
C!** RESET SEMICOLON FLAG
INS=-1
IF(J.GE.MM-1)GO TO 5
C!** GO READ ANOTHER LINE
305 CALL MSCAN(LL,W)
303 IF(IPRNT.LT.0)GO TO 306
IF(J.LT.MM)JSEM=-1
C!**** STILL MORE CHARS TO COME.
IF(ENDX.GE.0)GO TO 302
ENDX=0
GO TO 500
302 IF(JSEM)50,5,5
51 FORMAT(I3,35F10.3)
307 FORMAT('+',F8.2,$)
1307 FORMAT(F10.3)
END
FUNCTION NASCI(N)
DATA IEX/536870912/,IZERO/'0'/
C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
NASCI=(N-IZERO)/IEX
C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
END
SUBROUTINE CLOSIT(LL,W)
COMMON /KNAM/A,B,C,IOPEN
IOPEN=-1
RETURN
END